home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / files < prev    next >
Encoding:
Text File  |  1988-08-06  |  6.1 KB  |  162 lines
  1. \ this file provides a high-level interface to the Amiga file sys...
  2. \ It utilizes existing words in JKernal...FREAD, FSEEK, and FWRITE.
  3. \ It also defines a word f,.
  4. \ All file I/O is buffered through an area which is created once, the first
  5. \ time the file is accessed, and must be flushed before closing.
  6.  
  7. \   An application desiring a virtual-file workarea should:
  8. \  1. define a variable or user var to store a pointer to the area.
  9. \     (all vars are '0'ed at define time, but if the application is
  10. \      re-using an existing var, it should make sure the var is clear
  11. \      before step 2).
  12. \  2. Pass the address of this var to BufferAdr...BufferAdr will allocate
  13. \     (if the var holds 0) a 1024 byte area and return the relative adr,
  14. \     after installing it in the variable.
  15. \        If the var is not zero, then BufferAdr will just fetch its value.
  16. \     (App code is smaller with this approach as an app can just clear the
  17. \      var at its startup, and blindly pass through BufferAdr to get its area
  18. \      ...an area will only be allocated the first time!).  Either way,
  19. \     the stack diagram for BufferAdr is:   ( var-adr -- buffer-adr )
  20. \  3. Subsequent calls to the virtual word, f, and other defined later
  21. \     in 'FILES_EXTRA' will also take the var-addr on the stack to specify
  22. \     which (many may exist) virtual-workarea is to be operated on.
  23. \
  24. \ NOTE: currently, only sequential file I/O is supported virtually...
  25. \       these words include:
  26. \            fv, - ( file var-adr cell -- )  send cell to next place in file.
  27. \      read-line - ( file var-adr adr cnt -- cnt )  read intil eol to adr cnt,
  28. \                  return actual cnt read in.
  29. \
  30. \ *************** THE VIRTUAL FILE WORDS...
  31.  
  32. user tempfile
  33. user tempbuff
  34.  
  35. decimal 1024 constant virtbuffsize
  36.  
  37. : BufferAdr   ( var-adr -- addr , allocate 1k buffer for file access if necessary )
  38.   dup @ -dup 0=    ( var-adr true OR var-adr Buffadr false -- )
  39.   IF   memf_public virtbuffsize allocblock  -dup 0=
  40.        IF   .err ." Failed to allocate FileBuffer, fatal error."  quit
  41.        THEN        ( var-adr Buff-adr -- )   dup rot !   ( buff -- )
  42.   ELSE swap drop   ( buff -- )
  43.   THEN
  44. ;
  45.  
  46. : FFLUSH?   ( file var-adr -- , check if full, write to file if so )
  47.   \ NOTE that words using the file-virtual scheme should perform their
  48.   \      own check of FERROR after each use of  F,  for example...
  49.   bufferadr >r  ( file-- )   ( buff --r-- )
  50.   r freebyte   r sizemem   ( file #used #total --)  < 0=
  51.   IF   r r freebyte        ( file adr cnt -- )  fwrite drop
  52.        0 r freebytea !   ( clear the buffer )
  53.   ELSE drop
  54.   THEN r> drop   ;
  55.  
  56. : F,  ( file var-adr n1 -- )  ferror @
  57.   IF  3 xdrop
  58.   ELSE over >r >r  ( file var -- )       ( n1 var --R-- )
  59.        fflush?  r> r> @ push
  60.   THEN   ;
  61.  
  62. : tempf, ( n1 -- , user tempfile and tempbuff )
  63.   >r tempfile @  tempbuff r> f,  ;
  64.  
  65. : OpenFV  ( var-adr -- bufferadr )
  66.   0 over !    BufferAdr   ;
  67.   
  68. : CloseFVRead   ( var-adr -- , deallocate the buffer )
  69.   dup @ -dup 
  70.   IF    freeblock  0 over !
  71.   THEN  drop  ;
  72.  
  73. : CloseFVWrite  ( file var-adr -- , flush & deallocate the buffer )
  74.   >r   ( file -- )   ( var --R-- )
  75.   ferror @ 0=
  76.   IF  r @ -dup
  77.       IF    ( file buffadr -- )
  78.             dup freebyte ( file buffadr len -- )  -dup
  79.             IF   dup >r fwrite r> - ferror !  0   ( filler )
  80.             ELSE drop
  81.             THEN ( file OR 0 -- )
  82.       THEN  ( file -- )
  83.   THEN drop r> closefvread  ;
  84.  
  85. -1 constant OFFSET_BEGINNING
  86.  0 constant OFFSET_CURRENT
  87.  1 constant OFFSET_END
  88.  
  89.  
  90. \ these words support an area which, if allocated, will be assumed by
  91. \ 'quit' to be a table of file-pointers or memory blocks to be closed / freed
  92. \ in case of error.  (QUIT)
  93. \ additional words to help with memory allocations
  94.  
  95. : ALLOCBLOCK?   ( type size -- memory , errors out if error )
  96.   allocblock  -dup 0=
  97.   IF    .err ." Exec Library, AllocMem() failed"  quit
  98.   THEN  ;
  99.  
  100. : -STACK  ( member user_var -- , remove member if on stack pointed to by var)
  101.  
  102. \ the following is a general word which takes a data item and a var-addr..
  103. \ if the var is non-zero (holds an adr), search for the data in the blk,
  104. \ if found, remove from the stack.  If resulting stacksize is 0 (AND its not
  105. \ the 'FREEATBYE' stack, unallocate the stack memory block)
  106.  
  107.   swap over @  ( var n1 <var> -- )  -dup
  108.   IF   ( var n1 blk -- )
  109.        dup freebyte   ( var n1 blk #used -- )
  110.        2dup + cell-   ( var n1 blk #used last-cell-adr -- )  over cell/ 0
  111.        DO   dup  @  4 pick =
  112.             IF   ( var n1 blk #used matchadr -- )
  113.                  dup  cell+ over   ( var n1 blk #used matchadr from to -- )
  114.                  2 pick  5 pick -  ( matchadr-blk )
  115.                  4 pick  cell- swap - move  ( var n1 blk #used match -- )
  116.                  over cell-  dup >r  3 pick freebytea !
  117.                  ( var n1 blk #used match -- )
  118.                  4 pick  freeatbye = 0=  ( NOT FREEATBYE var? )
  119.                  r> 0= and               ( and size went to zero? )
  120.                  IF   2 pick freeblock   ( unallocate the memory block )
  121.                       0 5 pick !
  122.                  THEN leave
  123.             ELSE cell-
  124.             THEN
  125.        LOOP drop 2drop
  126.   THEN 2drop  ;
  127.  
  128. user NoTrack
  129.  
  130. : +stack  ( cell var -- push to stk held in var, allocate one if necessary)
  131.   dup @ -dup 0=
  132.   IF   ( cell var -- )
  133.        memf_clear  1024  NoTrack @
  134.        IF    XAllocBlk   -dup 0= Abort" No Memory!"
  135.        ELSE  AllocBlock?  ( cell var adr -- )
  136.        THEN  2dup swap !
  137.   ELSE ( -- cell var area )  dup sizemem over freebyte - 4 <
  138.        IF   ( -- cell var area1 )
  139.             dup sizemem dup >r 1024 +     ( -- cell var are1 a1-size+1k )
  140.             memf_clear swap  NoTrack @
  141.             IF    XAllocBlk   -dup 0= Abort" No Memory!"
  142.             ELSE  AllocBlock?   ( -- cell var area1 area2 )
  143.             THEN  2dup r> move   ( -- cell var area1 area2 )
  144.             over freebyte over freebytea !
  145.             swap freeblock ( -- cell var area2 )   2dup swap !
  146.        THEN
  147.   THEN swap drop  push     NoTrack off   ;
  148.  
  149. : markfreeblock   ( mem -- )
  150.   freeuplist +stack  ;
  151.  
  152. : unmarkfreeblock    ( mem -- )
  153.   freeuplist -stack  ;
  154.  
  155. : markfclose  ( file -- )
  156.   fcloselist +stack  ;
  157.  
  158. : unmarkfclose  ( file -- )
  159.   fcloselist -stack  ;
  160.  
  161. : DOS0 ( -- addr )   dosstring 2+  ;
  162.